home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Database Designers / Rational Rose 2000 / Rational Setup.EXE / common / lib / auto / Getopt / Long / FindOption.al < prev    next >
Encoding:
Text File  |  1999-01-26  |  7.7 KB  |  265 lines
  1. # NOTE: Derived from ../LIB\Getopt\Long.pm.
  2. # Changes made here will be lost when autosplit again.
  3. # See AutoSplit.pm.
  4. package Getopt::Long;
  5.  
  6. #line 500 "../LIB\Getopt\Long.pm (autosplit into ..\lib\auto/Getopt\Long/FindOption.al)"
  7. # Option lookup.
  8. sub FindOption ($$$$$$$) {
  9.  
  10.     # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
  11.     # returns (0) otherwise.
  12.  
  13.     my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
  14.     my $key;            # hash key for a hash option
  15.     my $arg;
  16.  
  17.     print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
  18.  
  19.     return (0) unless $opt =~ /^$prefix(.*)$/s;
  20.  
  21.     $opt = $+;
  22.     my ($starter) = $1;
  23.  
  24.     print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
  25.  
  26.     my $optarg = undef;    # value supplied with --opt=value
  27.     my $rest = undef;    # remainder from unbundling
  28.  
  29.     # If it is a long option, it may include the value.
  30.     if (($starter eq "--" || ($getopt_compat && !$bundling))
  31.     && $opt =~ /^([^=]+)=(.*)$/s ) {
  32.     $opt = $1;
  33.     $optarg = $2;
  34.     print STDERR ("=> option \"", $opt, 
  35.               "\", optarg = \"$optarg\"\n") if $debug;
  36.     }
  37.  
  38.     #### Look it up ###
  39.  
  40.     my $tryopt = $opt;        # option to try
  41.     my $optbl = $opctl;        # table to look it up (long names)
  42.     my $type;
  43.     my $dsttype = '';
  44.     my $incr = 0;
  45.  
  46.     if ( $bundling && $starter eq '-' ) {
  47.     # Unbundle single letter option.
  48.     $rest = substr ($tryopt, 1);
  49.     $tryopt = substr ($tryopt, 0, 1);
  50.     $tryopt = lc ($tryopt) if $ignorecase > 1;
  51.     print STDERR ("=> $starter$tryopt unbundled from ",
  52.               "$starter$tryopt$rest\n") if $debug;
  53.     $rest = undef unless $rest ne '';
  54.     $optbl = $bopctl;    # look it up in the short names table
  55.  
  56.     # If bundling == 2, long options can override bundles.
  57.     if ( $bundling == 2 and
  58.          defined ($type = $opctl->{$tryopt.$rest}) ) {
  59.         print STDERR ("=> $starter$tryopt rebundled to ",
  60.               "$starter$tryopt$rest\n") if $debug;
  61.         $tryopt .= $rest;
  62.         undef $rest;
  63.     }
  64.     } 
  65.  
  66.     # Try auto-abbreviation.
  67.     elsif ( $autoabbrev ) {
  68.     # Downcase if allowed.
  69.     $tryopt = $opt = lc ($opt) if $ignorecase;
  70.     # Turn option name into pattern.
  71.     my $pat = quotemeta ($opt);
  72.     # Look up in option names.
  73.     my @hits = grep (/^$pat/, @{$names});
  74.     print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
  75.               "out of ", scalar(@{$names}), "\n") if $debug;
  76.  
  77.     # Check for ambiguous results.
  78.     unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
  79.         # See if all matches are for the same option.
  80.         my %hit;
  81.         foreach ( @hits ) {
  82.         $_ = $aliases->{$_} if defined $aliases->{$_};
  83.         $hit{$_} = 1;
  84.         }
  85.         # Now see if it really is ambiguous.
  86.         unless ( keys(%hit) == 1 ) {
  87.         return (0) if $passthrough;
  88.         warn ("Option ", $opt, " is ambiguous (",
  89.               join(", ", @hits), ")\n");
  90.         $error++;
  91.         undef $opt;
  92.         return (1, $opt,$arg,$dsttype,$incr,$key);
  93.         }
  94.         @hits = keys(%hit);
  95.     }
  96.  
  97.     # Complete the option name, if appropriate.
  98.     if ( @hits == 1 && $hits[0] ne $opt ) {
  99.         $tryopt = $hits[0];
  100.         $tryopt = lc ($tryopt) if $ignorecase;
  101.         print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
  102.         if $debug;
  103.     }
  104.     }
  105.  
  106.     # Map to all lowercase if ignoring case.
  107.     elsif ( $ignorecase ) {
  108.     $tryopt = lc ($opt);
  109.     }
  110.  
  111.     # Check validity by fetching the info.
  112.     $type = $optbl->{$tryopt} unless defined $type;
  113.     unless  ( defined $type ) {
  114.     return (0) if $passthrough;
  115.     warn ("Unknown option: ", $opt, "\n");
  116.     $error++;
  117.     return (1, $opt,$arg,$dsttype,$incr,$key);
  118.     }
  119.     # Apparently valid.
  120.     $opt = $tryopt;
  121.     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
  122.  
  123.     #### Determine argument status ####
  124.  
  125.     # If it is an option w/o argument, we're almost finished with it.
  126.     if ( $type eq '' || $type eq '!' || $type eq '+' ) {
  127.     if ( defined $optarg ) {
  128.         return (0) if $passthrough;
  129.         warn ("Option ", $opt, " does not take an argument\n");
  130.         $error++;
  131.         undef $opt;
  132.     }
  133.     elsif ( $type eq '' || $type eq '+' ) {
  134.         $arg = 1;        # supply explicit value
  135.         $incr = $type eq '+';
  136.     }
  137.     else {
  138.         substr ($opt, 0, 2) = ''; # strip NO prefix
  139.         $arg = 0;        # supply explicit value
  140.     }
  141.     unshift (@ARGV, $starter.$rest) if defined $rest;
  142.     return (1, $opt,$arg,$dsttype,$incr,$key);
  143.     }
  144.  
  145.     # Get mandatory status and type info.
  146.     my $mand;
  147.     ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
  148.  
  149.     # Check if there is an option argument available.
  150.     if ( defined $optarg ? ($optarg eq '') 
  151.      : !(defined $rest || @ARGV > 0) ) {
  152.     # Complain if this option needs an argument.
  153.     if ( $mand eq "=" ) {
  154.         return (0) if $passthrough;
  155.         warn ("Option ", $opt, " requires an argument\n");
  156.         $error++;
  157.         undef $opt;
  158.     }
  159.     if ( $mand eq ":" ) {
  160.         $arg = $type eq "s" ? '' : 0;
  161.     }
  162.     return (1, $opt,$arg,$dsttype,$incr,$key);
  163.     }
  164.  
  165.     # Get (possibly optional) argument.
  166.     $arg = (defined $rest ? $rest
  167.         : (defined $optarg ? $optarg : shift (@ARGV)));
  168.  
  169.     # Get key if this is a "name=value" pair for a hash option.
  170.     $key = undef;
  171.     if ($dsttype eq '%' && defined $arg) {
  172.     ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
  173.     }
  174.  
  175.     #### Check if the argument is valid for this option ####
  176.  
  177.     if ( $type eq "s" ) {    # string
  178.     # A mandatory string takes anything. 
  179.     return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "=";
  180.  
  181.     # An optional string takes almost anything. 
  182.     return (1, $opt,$arg,$dsttype,$incr,$key) 
  183.       if defined $optarg || defined $rest;
  184.     return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ??
  185.  
  186.     # Check for option or option list terminator.
  187.     if ($arg eq $argend ||
  188.         $arg =~ /^$prefix.+/) {
  189.         # Push back.
  190.         unshift (@ARGV, $arg);
  191.         # Supply empty value.
  192.         $arg = '';
  193.     }
  194.     }
  195.  
  196.     elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
  197.     if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) {
  198.         $arg = $1;
  199.         $rest = $2;
  200.         unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
  201.     }
  202.     elsif ( $arg !~ /^-?[0-9]+$/ ) {
  203.         if ( defined $optarg || $mand eq "=" ) {
  204.         if ( $passthrough ) {
  205.             unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
  206.               unless defined $optarg;
  207.             return (0);
  208.         }
  209.         warn ("Value \"", $arg, "\" invalid for option ",
  210.               $opt, " (number expected)\n");
  211.         $error++;
  212.         undef $opt;
  213.         # Push back.
  214.         unshift (@ARGV, $starter.$rest) if defined $rest;
  215.         }
  216.         else {
  217.         # Push back.
  218.         unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
  219.         # Supply default value.
  220.         $arg = 0;
  221.         }
  222.     }
  223.     }
  224.  
  225.     elsif ( $type eq "f" ) { # real number, int is also ok
  226.     # We require at least one digit before a point or 'e',
  227.     # and at least one digit following the point and 'e'.
  228.     # [-]NN[.NN][eNN]
  229.     if ( $bundling && defined $rest &&
  230.          $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) {
  231.         $arg = $1;
  232.         $rest = $+;
  233.         unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
  234.     }
  235.     elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) {
  236.         if ( defined $optarg || $mand eq "=" ) {
  237.         if ( $passthrough ) {
  238.             unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
  239.               unless defined $optarg;
  240.             return (0);
  241.         }
  242.         warn ("Value \"", $arg, "\" invalid for option ",
  243.               $opt, " (real number expected)\n");
  244.         $error++;
  245.         undef $opt;
  246.         # Push back.
  247.         unshift (@ARGV, $starter.$rest) if defined $rest;
  248.         }
  249.         else {
  250.         # Push back.
  251.         unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
  252.         # Supply default value.
  253.         $arg = 0.0;
  254.         }
  255.     }
  256.     }
  257.     else {
  258.     Croak ("GetOpt::Long internal error (Can't happen)\n");
  259.     }
  260.     return (1, $opt, $arg, $dsttype, $incr, $key);
  261. }
  262.  
  263. # end of Getopt::Long::FindOption
  264. 1;
  265.